home *** CD-ROM | disk | FTP | other *** search
/ Ham Radio 2000 #2 / Ham Radio 2000 - Volume 2.iso / HAMV2 / TCP_IP / TNOS230S / FORTH.C < prev    next >
Encoding:
C/C++ Source or Header  |  1997-08-18  |  36.8 KB  |  1,562 lines
  1. /*             SM0RGV Forth
  2.  * Copyright 1990 by Anders Klemets, SM0RGV.  Permission granted for
  3.  * non-commercial distribution only.
  4.  */
  5. #include "global.h"
  6. #ifdef FORTH
  7. #include "ctype.h"
  8. #include "mbuf.h"
  9. #include "proc.h"
  10. #include "forth.h"
  11. #include "socket.h"
  12.  
  13. static void initforth (struct forth **taskp);
  14. static int goforth (struct forth *task);
  15. static int goword (struct forth *task, struct mbuf *bp);
  16. static int pop (struct mbuf **stack, int32 * valp);
  17. static int push (struct mbuf **stack, int32 val);
  18. #ifdef isnumber
  19. #undef isnumber
  20. #endif
  21. static int isnumber (char *word, char base);
  22. static int32 atoi32 (char *word, char base);
  23. static int errnostack (struct forth *task);
  24. static int dodot (struct forth *task);
  25. static int doaritm (struct forth *task);
  26. static int dounary (struct forth *task);
  27. static int dodup (struct forth *task);
  28. static int dodrop (struct forth *task);
  29. static int doover (struct forth *task);
  30. static int doswap (struct forth *task);
  31. static int dorot (struct forth *task);
  32. static int dopick (struct forth *task);
  33. static int dodepth (struct forth *task);
  34. static int dolist (struct forth *task);
  35. static int dobase (struct forth *task);
  36. static int dovariable (struct forth *task);
  37. static int doconstant (struct forth *task);
  38. static char *varcheck (struct forth *task, int32 addr);
  39. static int dofind (struct forth *task);
  40. static int dofetch (struct forth *task);
  41. static int doquestion (struct forth *task);
  42. static int dostore (struct forth *task);
  43. static int dostkmove (struct forth *task);
  44. static int doforget (struct forth *task);
  45. static int docolon (struct forth *task);
  46. static int doprint (struct forth *task);
  47. static int docr (struct forth *task);
  48. static int doemit (struct forth *task);
  49. static int dospaces (struct forth *task);
  50. static int dokey (struct forth *task);
  51. static int doifelse (struct forth *task);
  52. static int doforthnothing (struct forth *task);
  53. static int doforthuntil (struct forth *task);
  54. static int dodo (struct forth *task);
  55. static int doloop (struct forth *task);
  56. static int doload (struct forth *task);
  57. static int dobuffer (struct forth *task);
  58. static int doexpect (struct forth *task);
  59. static int doquit (struct forth *task);
  60.  
  61. static struct wordlist Vocabulary[] =
  62. {
  63.     { ".",        dodot,        0 },
  64.     { ".\"",    doprint,    '"' },
  65.     { "\"",        doprint,    '"' },
  66.     { "(",        doforthnothing,    ')' },
  67.     { ":",        docolon,    -1 },
  68.     { "+",        doaritm,    0 },
  69.     { "-",        doaritm,    0 },
  70.     { "*",        doaritm,    0 },
  71.     { "/",        doaritm,    0 },
  72.     { "=",        doaritm,    0 },
  73.     { "<",        doaritm,    0 },
  74.     { ">",        doaritm,    0 },
  75.     { "/MOD",    doaritm,    0 },
  76.     { "MOD",    doaritm,    0 },
  77.     { "*/MOD",    doaritm,    0 },
  78.     { "*/",        doaritm,    0 },
  79.     { "MAX",    doaritm,    0 },
  80.     { "MIN",    doaritm,    0 },
  81.     { "AND",    doaritm,    0 },
  82.     { "OR",        doaritm,    0 },
  83.     { "XOR",    doaritm,    0 },
  84.     { "0<",        dounary,    0 },
  85.     { "0=",        dounary,    0 },
  86.     { "0>",        dounary,    0 },
  87.     { "1+",        dounary,    0 },
  88.     { "1-",        dounary,    0 },
  89.     { "2+",        dounary,    0 },
  90.     { "2-",        dounary,    0 },
  91.     { "ABS",    dounary,    0 },
  92.     { "NOT",    dounary,    0 },
  93.     { "NEGATE",    dounary,    0 },
  94.     { "@",        dofetch,    0 },
  95.     { "C@",        dofetch,    0 },
  96.     { "?",        doquestion,    0 },
  97.     { "!",        dostore,    0 },
  98.     { "C!",        dostore,    0 },
  99.     { ">R",        dostkmove,    0 },
  100.     { "R>",        dostkmove,    0 },
  101.     { "'",        dofind,        -1 },
  102.     { "FIND",    dofind,        -1 },
  103.     { "?DUP",    dodup,        0 },
  104.     { "DUP",    dodup,        0 },
  105.     { "DROP",    dodrop,        0 },
  106.     { "OVER",    doover,        0 },
  107.     { "SWAP",    doswap,        0 },
  108.     { "ROT",    dorot,        0 },
  109.     { "PICK",    dopick,        0 },
  110.     { "DEPTH",    dodepth,    0 },
  111.     { "LIST",    dolist,        0 },
  112.     { "DECIMAL",    dobase,        0 },
  113.     { "HEX",    dobase,        0 },
  114.     { "OCTAL",    dobase,        0 },
  115.     { "VARIABLE",    dovariable,    -1 },
  116.     { "CONSTANT",    doconstant,    -1 },
  117.     { "FORGET",    doforget,    -1 },
  118.     { "IF",        doifelse,    0 },
  119.     { "ELSE",    doifelse,    0 },
  120.     { "THEN",    doforthnothing,    0 },
  121.     { "BEGIN",    doforthnothing,    0 },
  122.     { "UNTIL",    doforthuntil,    0 },
  123.     { "END",    doforthuntil,    0 },
  124.     { "AGAIN",    doforthuntil,    0 },
  125.     { "WHILE",    doforthuntil,    0 },
  126.     { "REPEAT",    doforthuntil,    0 },
  127.     { "DO",        dodo,        0 },
  128.     { "LOOP",    doloop,        0 },
  129.     { "+LOOP",    doloop,        0 },
  130.     { "LEAVE",    doloop,        0 },
  131.     { "I",        doloop,        0 },
  132.     { "J",        doloop,        0 },
  133.     { "CR",        docr,        0 },
  134.     { "SPACE",    dospaces,    0 },
  135.     { "SPACES",    dospaces,    0 },
  136.     { "EMIT",    doemit,        0 },
  137.     { "KEY",    dokey,        0 },
  138.     { "LOAD",    doload,        -1 },
  139.     { "PAD",    dobuffer,    0 },
  140.     { "BUFFER",    dobuffer,    0 },
  141.     { "EXPECT",    doexpect,    0 },
  142.     { "TYPE",    doexpect,    0 },
  143.     { "QUIT",    doquit,        0 },
  144.     { NULLCHAR,    NULLFP ((struct forth *)),
  145.                     0 }
  146. };
  147.  
  148.  
  149. static struct fvars Fixedvars[] =
  150. {
  151.     { "CLOCK",    FORTH_VARIABLE,    FORTH_READONLY + FORTH_INDIRECT, (int32) & Clock },
  152.     { "MSPTICK",    FORTH_CONSTANT,    FORTH_READONLY, MSPTICK },
  153. #if 0
  154.     { "IPADDR",    FORTH_CONSTANT,    FORTH_READONLY, (int32)Ip_addr },
  155. #endif
  156.     { "BASE",    FORTH_VARIABLE,    FORTH_INDIRECT,    0 },    /* must be last entry */
  157.     { NULLCHAR,    0,        0, 0 }
  158. };
  159.  
  160.  
  161.  
  162. static const char *synerr = "SYNTAX ERROR\n";
  163.  
  164.  
  165.  
  166. int
  167. doforth (int argc OPTIONAL, char *argv[] OPTIONAL, void *p OPTIONAL)
  168. {
  169. struct forth *task;
  170. int cnt;
  171. char line[1024];
  172. char *cp;
  173.  
  174.     initforth (&task);
  175.     tprintf ("SM0RGV Forth 1.1 Ready\n");
  176.     for ( ; ; ) {
  177.         if (task->fp != NULLFILE) {
  178.             if (fgets (line, 1024, task->fp) == NULLCHAR) {
  179.                 (void) fclose (task->fp);
  180.                 task->fp = NULLFILE;
  181.                 tprintf ("OK\n");
  182.                 continue;
  183.             } else
  184.                 cnt = (int) strlen (line);
  185.         } else if ((cnt = recvline (task->s, (unsigned char *) line, 1024)) == 0)
  186.             return 0;
  187.         if (cnt == 1) {    /* an empty line */
  188.             tprintf ("OK\n");
  189.             continue;
  190.         }
  191.         rip (line);    /* remove eol */
  192.         cnt = (int) strlen (line);
  193.         cp = &line[cnt - 1];
  194.         while (cp != line && *cp == ' ')    /* remove trailing blanks */
  195.             *cp-- = '\0';
  196.         /* convert to upper case */
  197. #if 0
  198.         for (i = 0; line[i] != '\0' && i < 1024; ++i)
  199.             if (islower (line[i]))
  200.                 line[i] = toupper(line[i]);
  201. #endif
  202.         task->word = line;
  203.         task->final = 0;
  204.         while (*task->word != '\0') {
  205.             if (task->delimiter == ' ')
  206.                 while (*task->word == ' ')    /* remove initial blanks */
  207.                     ++task->word;
  208.             cp = task->word + 1;
  209.             while (*cp != task->delimiter && *cp != '\0')
  210.                 ++cp;
  211.             if (*cp == '\0')
  212.                 task->final = 1;    /* this is the last word */
  213.             else
  214.                 *cp = '\0';
  215.             task->delimiter = ' ';
  216.             if (goforth (task) == -1) {
  217.                 free_q (&task->stack->next);    /* empty the stacks */
  218.                 task->stack->cnt = 0;
  219.                 free_q (&task->retstack->next);
  220.                 task->retstack->cnt = 0;
  221.                 break;
  222.             }
  223.             if (task->final) {
  224.                 *task->word = '\0';
  225.                 break;
  226.             }
  227.             task->word = cp + 1;
  228.         }
  229.         if (task->vocabulary == NULLBUF) {    /* QUIT executed */
  230.             (void) free_mbuf (task->stack);
  231.             (void) free_mbuf (task->retstack);
  232.             free ((char *) task);
  233.             return 0;
  234.         }
  235.         if (task->nextfkn == NULLFP((struct forth *)) && *task->word == '\0' &&
  236.             task->fp == NULLFILE)
  237.             tprintf ("OK\n");
  238.     }
  239. }
  240.  
  241.  
  242.  
  243. static void
  244. initforth (struct forth **taskp)
  245. {
  246. struct fvars *fv;
  247.  
  248.     *taskp = (struct forth *) callocw (1, sizeof (struct forth));
  249.  
  250.     (*taskp)->s = Curproc->input;
  251.     (*taskp)->delimiter = ' ';
  252.     (*taskp)->goaddr = -1;
  253.     while (((*taskp)->stack = alloc_mbuf (256)) == NULLBUF)
  254.         kwait (NULL);
  255.     while (((*taskp)->retstack = alloc_mbuf (256)) == NULLBUF)
  256.         kwait (NULL);
  257.     while (((*taskp)->pad = alloc_mbuf (256)) == NULLBUF)
  258.         kwait (NULL);
  259. #if 0
  260.     (int32) & (*taskp)->base;
  261. #endif
  262.     (*taskp)->base = 10;
  263.     fv = Fixedvars;
  264.     while (fv->name != NULLCHAR) {
  265.         (*taskp)->word = (char *) fv->name;
  266.         (void) dovariable (*taskp);
  267.         ((struct vocentry *) (*taskp)->vocabulary->data)->type = fv->type;
  268.         *((*taskp)->vocabulary->data + sizeof (struct vocentry)) = uchar(FORTH_SYSTEM + fv->options);
  269.         *(int32 *) ((*taskp)->vocabulary->data + 1 + sizeof (struct vocentry)) = fv->value;
  270.         ++fv;
  271.     }
  272.     *(int32 *) ((*taskp)->vocabulary->data + 1 + sizeof (struct vocentry))
  273.         =        (int32) & (*taskp)->base;    /* set the BASE variable */
  274. }
  275.  
  276.  
  277.  
  278. static int
  279. goforth (struct forth *task)
  280. {
  281. int ret;
  282. struct wordlist *wp;
  283. struct vocentry *ve;
  284. struct mbuf *bp;
  285.  
  286.     if (task->nextfkn != NULLFP((struct forth *))) {
  287.         ret = (*task->nextfkn) (task);
  288.         if (--task->args == 0 || ret == -1)
  289.             task->nextfkn = NULLFP((struct forth *));
  290.         return ret;
  291.     }
  292.     for (bp = task->vocabulary; bp != NULLBUF; bp = bp->anext) {
  293.         ve = (struct vocentry *) bp->data;
  294.         if (ve->length == (char) strlen (task->word) &&
  295.             strnicmp (task->word, ve->name, min (8, (unsigned int) (int) ve->length)) == 0)
  296.             return goword (task, bp);
  297.     }
  298.     wp = Vocabulary;
  299.     while (wp->name != NULLCHAR) {
  300.         if (stricmp (wp->name, task->word) == 0) {
  301.             if (wp->args > 0) {    /* delimiting character */
  302.                 /* do nothing if the rest of the line is empty */
  303.                 if (!task->final) {
  304.                     task->args = 1;
  305.                     task->delimiter = wp->args;
  306.                     task->nextfkn = wp->fkn;
  307.                 }
  308.                 return 0;
  309.             }
  310.             if (wp->args < 0)    /* this word takes arguments */
  311.                 if (task->final) {
  312.                     tputs ("MISSING ARGUMENT\n");
  313.                     return -1;
  314.                 } else {
  315.                     task->args = -wp->args;
  316.                     task->nextfkn = wp->fkn;
  317.                     return 0;
  318.                 }
  319.             return (*wp->fkn) (task);    /* a normal word */
  320.         }
  321.         wp++;
  322.     }
  323.     if (isnumber (task->word, (char) task->base))
  324.         return push (&task->stack, atoi32 (task->word, (char) task->base));
  325.     tprintf ("%s?\n", task->word);
  326.     return -1;
  327. }
  328.  
  329.  
  330.  
  331. /* execute a word from the local vocabulary */
  332. static int
  333. goword (struct forth *task, struct mbuf *bp)
  334. {
  335. struct vocentry *ve;
  336. char *oldword, *p;
  337. int ret = 0;
  338.  
  339.     ve = (struct vocentry *) bp->data;
  340.     p = (char *) (ve + 1);
  341.     if (ve->type == FORTH_VARIABLE)
  342.         return push (&task->stack, (int32) (bp->data +
  343.                          sizeof (struct vocentry) + 1));
  344.  
  345.     if (ve->type == FORTH_CONSTANT)
  346.         if (*p & FORTH_INDIRECT)
  347.             return push (&task->stack, **(int32 **) (p + 1));
  348.         else
  349.             return push (&task->stack, *(int32 *) (p + 1));
  350.     oldword = task->word;
  351.     task->final = 0;
  352.     /* now handling FORTH_WORD */
  353.     while (*p != FORTH_END) {
  354.         kwait (NULL);
  355.         switch (*p++) {
  356.             case FORTH_LOCALENTRY:
  357.                 task->word = ((struct vocentry *) (*(struct mbuf **) p)->data)->name;
  358.                 ret = goword (task, *(struct mbuf **) p);
  359.                 p += sizeof (struct mbuf *);
  360.  
  361.                 break;
  362.             case FORTH_FIXEDENTRY:
  363.                 task->word = (char *) (*(struct wordlist **) p)->name;
  364.                 if ((*(struct wordlist **) p)->args != 0)
  365.                     task->nextfkn = (*(struct wordlist **) p)->fkn;
  366.                 else
  367.                     ret = (*(*(struct wordlist **) p)->fkn) (task);
  368.                 if (task->goaddr != -1) {    /* a goto facility */
  369.                     /* convert the logical address into a "physical" one */
  370.                     p = (char *) (ve + 1) + task->goaddr;
  371.                     task->goaddr = -1;
  372.                 } else
  373.                     p += sizeof (struct wordlist *);
  374.  
  375.                 break;
  376.             case FORTH_INT32:
  377.                 ret = push (&task->stack, *(int32 *) p);
  378.                 p += sizeof (int32);
  379.                 break;
  380.             case FORTH_RETSTACK:
  381.                 ret = push (&task->retstack, *(int32 *) p);
  382.                 p += sizeof (int32);
  383.                 break;
  384.             case FORTH_ARGUMENT:
  385.                 task->word = *(char **) p;
  386.                 ret = (*task->nextfkn) (task);
  387.                 p += sizeof (char *);
  388.  
  389.                 break;
  390.             default:
  391.                 break;
  392.         }
  393.         if (ret == -1) {
  394.             task->word = oldword;
  395.             return -1;
  396.         }
  397.     }
  398.     task->word = oldword;
  399.     task->nextfkn = NULLFP((struct forth *));    /* in case it had been changed */
  400.     return 0;
  401. }
  402.  
  403.  
  404.  
  405. static int
  406. isnumber (char *word, char base)
  407. {
  408. char *cp;
  409.  
  410.     cp = word;
  411.     if (*cp == '\0')
  412.         return 0;
  413.     if (*cp == '-' || *cp == '+')
  414.         ++cp;
  415.     while (*cp != '\0') {
  416.         if (base <= 10 && (*cp < '0' || *cp > ('0' + base - 1)))
  417.             return 0;
  418.         if (base > 10 && !isdigit (*cp) && (*cp < 'A' || *cp > ('a' + base - 11)
  419.                  || (*cp > ('A' + base - 11) && *cp < 'a')))
  420.             return 0;
  421.         ++cp;
  422.     }
  423.     return 1;
  424. }
  425.  
  426.  
  427.  
  428. static int32
  429. atoi32 (char *word, char base)
  430. {
  431. int32 val = 0;
  432. int cnt, factor = 1;
  433. char *p = word;
  434.  
  435.     if (*p == '-') {
  436.         factor = -1;
  437.         ++p;
  438.     } else if (*p == '+')
  439.         ++p;
  440.     for (cnt = (int) strlen (p) - 1; cnt >= 0; --cnt) {
  441.         if (isdigit (p[cnt]))
  442.             val += (p[cnt] - '0') * factor;
  443.         else if (isupper (p[cnt]))
  444.             val += (p[cnt] - 'A' + 10) * factor;
  445.         else
  446.             val += (p[cnt] - 'a' + 10) * factor;
  447.         factor *= base;
  448.     }
  449.     return val;
  450. }
  451.  
  452.  
  453.  
  454. static int
  455. errnostack (struct forth *task)
  456. {
  457.     tprintf ("0 %s STACK EMPTY\n", task->word);
  458.     return -1;
  459. }
  460.  
  461.  
  462.  
  463. static int
  464. pop (struct mbuf **stack, int32 *valp)
  465. {
  466. struct mbuf *bp;
  467.  
  468.     bp = *stack;
  469.     if (bp->cnt == 0)
  470.         if (bp->next == NULLBUF)
  471.             return -1;
  472.         else {
  473.             *stack = bp->next;
  474.             (void) free_mbuf (bp);
  475.             bp = *stack;
  476.         }
  477.     *valp = *((int32 *) bp->data + 64 - bp->cnt--);
  478.     return 0;
  479. }
  480.  
  481.  
  482.  
  483. static int 
  484. push (struct mbuf **stack, int32 val)
  485. {
  486. struct mbuf *bp;
  487.  
  488.     if ((*stack)->cnt == 64) {
  489.         while ((bp = alloc_mbuf (256)) == NULLBUF)
  490.             kwait (NULL);
  491.         bp->next = *stack;        /*lint !e794 */
  492.         *stack = bp;
  493.     }
  494.     *((int32 *) (*stack)->data + 64 - ++(*stack)->cnt) = val;
  495.     return 0;
  496. }
  497.  
  498.  
  499.  
  500. static int
  501. dodot (struct forth *task)
  502. {
  503. char buf[1024], *cp;
  504. int32 val, tmp;
  505.  
  506.     if (pop (&task->stack, &val) == -1)
  507.         return errnostack (task);
  508.     if (task->base == 10) {    /* special case */
  509.         tprintf ("%ld ", val);
  510.         return 0;
  511.     }
  512.     if (val < 0) {
  513.         tputc ('-');
  514.         val = ~val + 1;        /*lint !e502 */
  515.     }
  516.     cp = buf;
  517.     while (val != 0) {
  518.         tmp = val % task->base;
  519.         if (tmp < 10)
  520.             *cp = (char) ('0' + tmp);
  521.         else
  522.             *cp = (char) ('A' + tmp - 10);
  523.         val /= task->base;
  524.         ++cp;
  525.     }
  526.     if (cp != buf) {
  527.         while (--cp >= buf)
  528.             tputc (uchar(*cp));
  529.         tputc (' ');
  530.     } else
  531.         tprintf ("0 ");
  532.     return 0;
  533. }
  534.  
  535.  
  536.  
  537. static int
  538. doaritm (struct forth *task)
  539. {
  540. int32 val1, val2, val3;
  541.  
  542.     if (pop (&task->stack, &val1) == -1)
  543.         return errnostack (task);
  544.     if (pop (&task->stack, &val2) == -1)
  545.         return errnostack (task);
  546.     switch (task->word[0]) {
  547.         case '+':
  548.             return push (&task->stack, val2 + val1);
  549.         case '-':
  550.             return push (&task->stack, val2 - val1);
  551.         case '*':
  552.             if (task->word[1] == '\0')
  553.                 return push (&task->stack, val2 * val1);    /* pure multiplication */
  554.             else {
  555.                 if (pop (&task->stack, &val3) == -1)    /* "* /" operation */
  556.                     return errnostack (task);
  557.                 if (task->word[2] != '\0')    /* "* /MOD" */
  558.                     (void) push (&task->stack, val3 * val2 % val1);
  559.                 return push (&task->stack, val3 * val2 / val1);
  560.             }
  561.         case '/':
  562.             if (task->word[1] != '\0')
  563.                 (void) push (&task->stack, val2 % val1);    /* /MOD operation */
  564.             return push (&task->stack, val2 / val1);    /* pure division */
  565.         case '<':
  566.             return push (&task->stack, val2 < val1);
  567.         case '>':
  568.             return push (&task->stack, val2 > val1);
  569.         case '=':
  570.             return push (&task->stack, val2 == val1);
  571.         case 'M':
  572.         case 'm':
  573.             if (task->word[1] == 'a' || task->word[1] == 'A')    /* MAX */
  574.                 return push (&task->stack, max (val2, val1));
  575.             if (task->word[1] == 'i' || task->word[1] == 'I')    /* MIN */
  576.                 return push (&task->stack, min (val2, val1));
  577.             return push (&task->stack, val2 % val1);    /* MOD operation */
  578.         case 'a':
  579.         case 'A':
  580.             return push (&task->stack, val2 & val1);
  581.         case 'o':
  582.         case 'O':
  583.             return push (&task->stack, val2 | val1);
  584.         case 'x':
  585.         case 'X':
  586.             return push (&task->stack, val2 ^ val1);
  587.         default:
  588.             break;
  589.     }
  590.     return 0;
  591. }
  592.  
  593.  
  594.  
  595. static int
  596. dounary (struct forth *task)
  597. {
  598. int32 val;
  599.  
  600.     if (pop (&task->stack, &val) == -1)
  601.         return errnostack (task);
  602.     switch (task->word[0]) {
  603.         case '1':
  604.             if (task->word[1] == '+')
  605.                 return push (&task->stack, val + 1);
  606.             return push (&task->stack, val - 1);
  607.         case '0':
  608.         case 'n':
  609.         case 'N':
  610.             if (task->word[1] == '<')
  611.                 return push (&task->stack, val < 0);
  612.             if (task->word[1] == '>')
  613.                 return push (&task->stack, val > 0);
  614.             if (task->word[1] == 'e' || task->word[1] == 'E')
  615.                 return push (&task->stack, -val);    /* NEGATE */
  616.             return push (&task->stack, !val);    /* NOT, 0= */
  617.         case '2':
  618.             if (task->word[1] == '+')
  619.                 return push (&task->stack, val + 2);
  620.             return push (&task->stack, val - 2);
  621.         case 'a':
  622.         case 'A':
  623.             return push (&task->stack, val < 0 ? -val : val);    /* ABS */
  624.         default:
  625.             break;
  626.     }
  627.     return 0;
  628. }
  629.  
  630.  
  631.  
  632. static int
  633. dodup (struct forth *task)
  634. {
  635. int32 val;
  636.  
  637.     if (task->stack->cnt == 0)
  638.         if (task->stack->next == NULLBUF)
  639.             return errnostack (task);
  640.         else
  641.             val = *(int32 *) task->stack->next->data;
  642.     else
  643.         val = *((int32 *) task->stack->data + 64 - task->stack->cnt);
  644.     if (task->word[0] == '?' && val == 0)    /* ?DUP */
  645.         return 0;
  646.     return push (&task->stack, val);
  647. }
  648.  
  649.  
  650.  
  651. static int
  652. dodrop (struct forth *task)
  653. {
  654. int32 val;
  655.  
  656.     return pop (&task->stack, &val);
  657. }
  658.  
  659.  
  660.  
  661. static int
  662. doover (struct forth *task)
  663. {
  664. struct mbuf *bp;
  665.  
  666.     if (task->stack->cnt > 1)
  667.         return push (&task->stack, *((int32 *) task->stack->data + 64 + 1 -
  668.                          task->stack->cnt));
  669.     if ((bp = task->stack->next) == NULLBUF)
  670.         return errnostack (task);
  671.     return push (&task->stack, *((int32 *) bp->data + 64 + 1 - task->stack->cnt -
  672.                      bp->cnt));
  673. }
  674.  
  675.  
  676.  
  677. static int
  678. doswap (struct forth *task)
  679. {
  680. int32 val1, val2;
  681.  
  682.     if (pop (&task->stack, &val1) == -1)
  683.         return errnostack (task);
  684.     if (task->stack->cnt > 0) {
  685.         val2 = *((int32 *) task->stack->data + 64 - task->stack->cnt);
  686.         *((int32 *) task->stack->data + 64 - task->stack->cnt) = val1;
  687.     } else {
  688.         if (task->stack->next == NULLBUF)
  689.             return errnostack (task);
  690.         val2 = *(int32 *) task->stack->next->data;
  691.         *(int32 *) task->stack->next->data = val1;
  692.     }
  693.     return push (&task->stack, val2);
  694. }
  695.  
  696.  
  697.  
  698. static int
  699. dorot (struct forth *task)
  700. {
  701. int32 val1, val2, val3;
  702.  
  703.     if (pop (&task->stack, &val1) == -1)
  704.         return errnostack (task);
  705.     if (pop (&task->stack, &val2) == -1)
  706.         return errnostack (task);
  707.     if (task->stack->cnt > 0) {
  708.         val3 = *((int32 *) task->stack->data + 64 - task->stack->cnt);
  709.         *((int32 *) task->stack->data + 64 - task->stack->cnt) = val2;
  710.     } else {
  711.         if (task->stack->next == NULLBUF)
  712.             return errnostack (task);
  713.         val3 = *(int32 *) task->stack->next->data;
  714.         *(int32 *) task->stack->next->data = val2;
  715.     }
  716.     (void) push (&task->stack, val1);
  717.     return push (&task->stack, val3);
  718. }
  719.  
  720.  
  721.  
  722. static int
  723. dopick (struct forth *task)
  724. {
  725. struct mbuf *bp;
  726. int32 val;
  727.  
  728.     if (pop (&task->stack, &val) == -1)
  729.         return errnostack (task);
  730.     if (val > 0) {
  731.         bp = task->stack;
  732.         while (bp != NULLBUF && bp->cnt < val) {
  733.             val -= bp->cnt;
  734.             bp = bp->next;
  735.         }
  736.         if (bp != NULLBUF)
  737.             return push (&task->stack, *((int32 *) bp->data + 64 - 1 + val
  738.                              - bp->cnt));
  739.     }
  740.     return errnostack (task);
  741. }
  742.  
  743.  
  744.  
  745. static int
  746. dodepth (struct forth *task)
  747. {
  748.     return push (&task->stack, (int32) len_p (task->stack));
  749. }
  750.  
  751.  
  752.  
  753. static int
  754. dolist (struct forth *task)
  755. {
  756. int cnt = 0;
  757. struct wordlist *wp;
  758. struct vocentry *ve;
  759. struct mbuf *bp;
  760.  
  761.     bp = task->vocabulary;
  762.     while (bp != NULLBUF) {
  763.         ve = (struct vocentry *) bp->data;
  764.         tprintf ("%-8s", ve->name);
  765.         bp = bp->anext;
  766.         ++cnt;
  767.         if (cnt % 8 == 0)
  768.             tprintf ("\n");
  769.         else
  770.             tprintf ("  ");
  771.     }
  772.     wp = Vocabulary;
  773.     while (wp->name != NULLCHAR) {
  774.         tprintf ("%-8s", wp->name);
  775.         cnt++;
  776.         if (cnt % 8 == 0)
  777.             tprintf ("\n");
  778.         else
  779.             tprintf ("  ");
  780.         wp++;
  781.     }
  782.     if (cnt % 8 != 0)
  783.         tprintf ("\n");
  784.     return 0;
  785. }
  786.  
  787.  
  788.  
  789. static int
  790. dobase (struct forth *task)
  791. {
  792.     switch (task->word[0]) {
  793.         case 'D':
  794.         case 'd':
  795.             task->base = 10;
  796.             break;
  797.         case 'H':
  798.         case 'h':
  799.             task->base = 16;
  800.             break;
  801.         default:
  802.             task->base = 8;
  803.     }
  804.     return 0;
  805. }
  806.  
  807.  
  808.  
  809. static int
  810. dovariable (struct forth *task)
  811. {
  812. struct vocentry *ve;
  813. struct mbuf *bp;
  814.  
  815.     while ((bp = alloc_mbuf (sizeof (struct vocentry) + 1 + sizeof (int32))) == NULLBUF)
  816.         kwait (NULL);
  817.  
  818.     if (bp == NULLBUF)    /* shouldn't happen - to satisfy lint */
  819.         return 0;
  820.     bp->cnt = bp->size;
  821.     ve = (struct vocentry *) bp->data;
  822.     ve->type = FORTH_VARIABLE;
  823.     ve->length = (char) strlen (task->word);
  824.     if (ve->length < 9)
  825.         strcpy (ve->name, task->word);
  826.     else {
  827.         strncpy (ve->name, task->word, 8);
  828.         ve->name[8] = '\0';
  829.     }
  830.     *(bp->data + sizeof (struct vocentry)) = FORTH_NORMAL;
  831.  
  832.     /* the variable is initialized to zero */
  833.     *(int32 *) (bp->data + sizeof (struct vocentry) + 1) = 0;
  834.  
  835.     bp->anext = task->vocabulary;
  836.     task->vocabulary = bp;
  837.     return 0;
  838. }
  839.  
  840.  
  841.  
  842. static int
  843. doconstant (struct forth *task)
  844. {
  845. int32 val;
  846. struct vocentry *ve;
  847.  
  848.     if (pop (&task->stack, &val) == -1)
  849.         return errnostack (task);
  850.     (void) dovariable (task);
  851.     ve = (struct vocentry *) task->vocabulary->data;
  852.     ve->type = FORTH_CONSTANT;
  853.     *(int32 *) (task->vocabulary->data + sizeof (struct vocentry) + 1) = val;
  854.  
  855.     return 0;
  856. }
  857.  
  858.  
  859.  
  860. /* check if the value on the stack is a pointer to a variable or a constant,
  861.  * and if so return a pointer to the begining of the data area that keeps
  862.  * the object.
  863.  */
  864. static char *
  865. varcheck (struct forth *task, int32 addr)
  866. {
  867. struct mbuf *bp;
  868. struct vocentry *ve;
  869.  
  870.     bp = task->vocabulary;
  871.     while (bp != NULLBUF)    /* integrity check */
  872.         if (addr >= (int32) (bp->data + sizeof (struct vocentry) + 1) && addr <
  873.                      (int32) (bp->data + sizeof (struct vocentry) + 1 + sizeof (int32)))
  874.                      break;
  875.  
  876.         else
  877.             bp = bp->anext;
  878.     if (bp != NULLBUF) {
  879.         ve = (struct vocentry *) bp->data;
  880.         if (ve->type != FORTH_VARIABLE && ve->type != FORTH_CONSTANT) {
  881.             tprintf ("WRONG KIND OF OBJECT\n");
  882.             return NULLCHAR;
  883.         }
  884.         return (char *) (bp->data + sizeof (struct vocentry));
  885.     }
  886.     /* try to see if the address is to a buffer */
  887.     bp = task->pad;
  888.     while (bp != NULLBUF)
  889.         if (addr >= (int32) (bp->data + 1) && addr <= (int32) & bp->data[255])
  890.             return (char *) bp->data;
  891.         else
  892.             bp = bp->anext;
  893.     tprintf ("INVALID ARGUMENT\n");
  894.     return NULLCHAR;
  895. }
  896.  
  897.  
  898.  
  899. static int
  900. dofind (struct forth *task)
  901. {
  902. struct mbuf *bp;
  903. struct vocentry *ve;
  904. struct wordlist *wp;
  905.  
  906.     bp = task->vocabulary;
  907.     while (bp != NULLBUF) {
  908.         ve = (struct vocentry *) bp->data;
  909.         if (ve->length == (char) strlen (task->word) &&
  910.           strnicmp (ve->name, task->word, (unsigned int) (int) min (ve->length, 8)) == 0)
  911.             return push (&task->stack, (int32) (bp->data +
  912.                          sizeof (struct vocentry) + 1));
  913.  
  914.         bp = bp->anext;
  915.     }
  916.     wp = Vocabulary;
  917.     while (wp->name != NULLCHAR) {
  918.         if (stricmp (wp->name, task->word) == 0)
  919.             return push (&task->stack, (int32) wp);
  920.         ++wp;
  921.     }
  922.     tprintf ("%s?\n", task->word);
  923.     return -1;
  924. }
  925.  
  926.  
  927.  
  928. static int
  929. dofetch (struct forth *task)
  930. {
  931. int32 addr, val;
  932. char *p;
  933.  
  934.     if (pop (&task->stack, &addr) == -1)
  935.         return errnostack (task);
  936.     if ((p = varcheck (task, addr)) == NULLCHAR)
  937.         return -1;
  938.     if (task->word[1] != '\0') {    /* C@ */
  939.         if (*p & FORTH_INDIRECT)
  940.             val = *(*(char **) (p + 1) + addr - (int) (p + 1));
  941.         else
  942.             val = *(char *) addr;
  943.     } else {
  944.         if ((p = varcheck (task, addr + (int32) sizeof (int32) - 1)) == NULLCHAR)
  945.             return -1;
  946.         if (*p & FORTH_INDIRECT)
  947.             val = *(*(int32 **) (p + 1) + addr - (int) (p + 1));
  948.         else
  949.             val = *(int32 *) addr;
  950.     }
  951.     return push (&task->stack, val);
  952. }
  953.  
  954.  
  955.  
  956. static int
  957. doquestion (struct forth *task)
  958. {
  959.     if (dofetch (task) == -1)
  960.         return -1;
  961.     return dodot (task);
  962. }
  963.  
  964.  
  965.  
  966. static int
  967. dostore (struct forth *task)
  968. {
  969. char *p;
  970. int32 addr, val;
  971.  
  972.     if (pop (&task->stack, &addr) == -1)
  973.         return errnostack (task);
  974.     if (pop (&task->stack, &val) == -1)
  975.         return errnostack (task);
  976.     if ((p = varcheck (task, addr)) == NULLCHAR)
  977.         return -1;
  978.     if (*p & FORTH_READONLY) {
  979.         tprintf ("WRITE PROTECTED ADDRESS\n");
  980.         return -1;
  981.     }
  982.     if (task->word[1] != '\0') {    /* C! word */
  983.         if (*p & FORTH_INDIRECT)
  984.             *(*(char **) (p + 1) + addr - (int) (p + 1)) = (char) val;
  985.         else
  986.             *(char *) addr = (char) val;
  987.     } else {
  988.         if ((p = varcheck (task, addr + (int32) sizeof (int32) - 1)) == NULLCHAR)    /* ! */
  989.             return -1;
  990.         if (*p & FORTH_INDIRECT)
  991.             *(*(int32 **) (p + 1) + addr - (int) (p + 1)) = val;
  992.         else
  993.             *(int32 *) addr = val;
  994.     }
  995.     return 0;
  996. }
  997.  
  998.  
  999.  
  1000. static int
  1001. dostkmove (struct forth *task)
  1002. {
  1003. int32 val;
  1004.  
  1005.     if (task->word[0] == '>') {    /* >R */
  1006.         if (pop (&task->stack, &val) == -1)
  1007.             return errnostack (task);
  1008.         return push (&task->retstack, val);
  1009.     }
  1010.     if (pop (&task->retstack, &val) == -1)    /* R> */
  1011.         return errnostack (task);
  1012.     return push (&task->stack, val);
  1013. }
  1014.  
  1015.  
  1016.  
  1017. static int
  1018. doforget (struct forth *task)
  1019. {
  1020. struct mbuf *bp, *bp2, *bp3;
  1021. char c, *p;
  1022. int noway = 0;
  1023. struct wordlist *wp;
  1024. struct vocentry *ve;
  1025.  
  1026.     bp = task->vocabulary;
  1027.     while (bp != NULLBUF) {
  1028.         ve = (struct vocentry *) bp->data;
  1029.         if (ve->type == FORTH_VARIABLE || ve->type == FORTH_CONSTANT)
  1030.             if (*(bp->data + sizeof (struct vocentry)) != FORTH_NORMAL)
  1031.                          noway = 1;
  1032.  
  1033.         if (ve->length == (char) strlen (task->word) &&
  1034.           strnicmp (ve->name, task->word, (unsigned int) (int) min (ve->length, 8)) == 0)
  1035.             break;
  1036.         bp = bp->anext;
  1037.     }
  1038.     if (noway) {
  1039.         tprintf ("CANNOT FORGET %s\n", task->word);
  1040.         return -1;
  1041.     }
  1042.     if (bp == NULLBUF) {    /* no match */
  1043.         for (wp = Vocabulary; wp->name != NULLCHAR; ++wp)
  1044.             if (stricmp (wp->name, task->word) == 0) {
  1045.                 tprintf ("CANNOT FORGET %s\n", wp->name);
  1046.                 return -1;
  1047.             }
  1048.         tprintf ("%s?\n", task->word);
  1049.         return -1;
  1050.     }
  1051.     bp2 = bp->anext;
  1052.     bp->anext = NULLBUF;
  1053.     bp = task->vocabulary;
  1054.     /* the list must be searched for FORTH_ARGUMENT entries,
  1055.      * since they have pointers to areas that must be freed.
  1056.      */
  1057.     while (bp != NULLBUF) {
  1058.         ve = (struct vocentry *) bp->data;
  1059.         if (ve->type != FORTH_WORD) {
  1060.             bp = free_p (bp);
  1061.             continue;
  1062.         }
  1063.         bp3 = bp->anext;
  1064.         (void) pullup (&bp, (unsigned char *)0, sizeof (struct vocentry));
  1065.  
  1066.         c = (char) pullchar (&bp);
  1067.         while (c != FORTH_END) {
  1068.             switch (c) {
  1069.                 case FORTH_LOCALENTRY:
  1070.                     (void) pullup (&bp, (unsigned char *)0, sizeof (struct mbuf *));
  1071.  
  1072.                     break;
  1073.                 case FORTH_FIXEDENTRY:
  1074.                     (void) pullup (&bp, (unsigned char *)0, sizeof (struct wordlist *));
  1075.  
  1076.                     break;
  1077.                 case FORTH_INT32:
  1078.                 case FORTH_RETSTACK:
  1079.                     (void) pullup (&bp, (unsigned char *)0, sizeof (int32));
  1080.                     break;
  1081.                 case FORTH_ARGUMENT:
  1082.                     (void) pullup (&bp, (unsigned char *) &p, sizeof (char *));
  1083.  
  1084.                     free (p);
  1085.                     break;
  1086.                 default:
  1087.                     break;
  1088.             }
  1089.             c = (char) pullchar (&bp);
  1090.         }
  1091.         free_p (bp);    /* in case there's something left */
  1092.         bp = bp3;
  1093.     }
  1094.     task->vocabulary = bp2;
  1095.     return 0;
  1096. }
  1097.  
  1098.  
  1099.  
  1100. static int
  1101. docolon (struct forth *task)
  1102. {
  1103. char *cp;
  1104. struct mbuf *bp;
  1105. struct wordlist *wp;
  1106. struct vocentry *ve;
  1107. int32 val;
  1108.  
  1109.     if (task->fc == (struct fcompiler *) 0) {
  1110.         task->fc = (struct fcompiler *) mallocw (sizeof (struct fcompiler));
  1111.  
  1112.         task->fc->arg = 0;
  1113.         task->fc->first = 1;
  1114.         task->fc->base = (char) task->base;
  1115.         task->fc->p = task->fc->buf;
  1116.     }
  1117.     if (task->final && strcmp (task->word, ";") == 0) {
  1118.         *task->fc->p++ = FORTH_END;
  1119.         while ((bp = alloc_mbuf ((int16) (sizeof (task->fc->v) + task->fc->p -
  1120.                      task->fc->buf))) == NULLBUF)
  1121.             kwait (NULL);
  1122.         if (bp == NULLBUF)
  1123.             return 0;
  1124.         bp->cnt = bp->size;
  1125.         memcpy (bp->data, (char *) &task->fc->v, sizeof (task->fc->v));
  1126.         memcpy (bp->data + sizeof (task->fc->v), task->fc->buf,
  1127.             (unsigned int) (task->fc->p - task->fc->buf));
  1128.         free ((char *) task->fc);
  1129.         bp->anext = task->vocabulary;
  1130.         task->vocabulary = bp;
  1131.         return 0;
  1132.     } else
  1133.         ++task->args;
  1134.     if (task->fc->first) {    /* set the name */
  1135.         task->fc->v.type = FORTH_WORD;
  1136.         task->fc->v.length = (char) strlen (task->word);
  1137.         if (task->fc->v.length < 9)
  1138.             strcpy (task->fc->v.name, task->word);
  1139.         else {
  1140.             strncpy (task->fc->v.name, task->word, 8);
  1141.             task->fc->v.name[8] = '\0';
  1142.         }
  1143.         task->fc->first = 0;
  1144.         return 0;
  1145.     }
  1146.     if (task->fc->arg == 0) {    /* we are expecting no arguments */
  1147.         bp = task->vocabulary;
  1148.         while (bp != NULLBUF) {
  1149.             ve = (struct vocentry *) bp->data;
  1150.             if (ve->length == (char) strlen (task->word) &&
  1151.                 strnicmp (ve->name, task->word, min (8, (unsigned int) (int) ve->length)) == 0) {
  1152.                 *task->fc->p++ = FORTH_LOCALENTRY;
  1153.                 *(struct mbuf **) task->fc->p = bp;
  1154.                 task->fc->p += sizeof (bp);
  1155.                 return 0;
  1156.             }
  1157.             bp = bp->anext;
  1158.         }
  1159.         wp = Vocabulary;
  1160.         while (wp->name != NULLCHAR) {
  1161.             if (stricmp (wp->name, task->word) == 0) {
  1162.                 /* treat some special cases */
  1163.                 if (stricmp (wp->name, "DO") == 0) {
  1164.                     *task->fc->p++ = FORTH_RETSTACK;
  1165.                     *(int32 *) task->fc->p = (int32) sizeof (int32) + (int32) sizeof (wp)
  1166.                         + 1 + (int32) (task->fc->p - task->fc->buf);
  1167.                     task->fc->p += sizeof (int32);
  1168.                 }
  1169.                 if (stricmp (wp->name, "BEGIN") == 0) {
  1170.                     *task->fc->p++ = FORTH_RETSTACK;
  1171.                     *(int32 *) task->fc->p = (int32) (task->fc->p - 1 -
  1172.                                  task->fc->buf);
  1173.                     task->fc->p += sizeof (int32);
  1174.                     return 0;
  1175.                 }
  1176.                 if (stricmp (wp->name, "WHILE") == 0) {
  1177.                     *task->fc->p++ = FORTH_RETSTACK;
  1178.                     (void) push (&task->retstack, (int32) task->fc->p);
  1179.                     task->fc->p += sizeof (int32);
  1180.                 }
  1181.                 if (stricmp (wp->name, "REPEAT") == 0) {
  1182.                     if (pop (&task->retstack, &val) == -1) {
  1183.                         tputs (synerr);
  1184.                         free ((char *) task->fc);
  1185.                         return -1;
  1186.                     }
  1187.                     *(int32 *) val = (int32) (task->fc->p - task->fc->buf)
  1188.                         + 1 + (int32) sizeof (wp);
  1189.                 }
  1190.                 if (stricmp (wp->name, "IF") == 0) {
  1191.                     *task->fc->p++ = FORTH_RETSTACK;
  1192.                     (void) push (&task->retstack, (int32) task->fc->p);
  1193.                     task->fc->p += sizeof (int32);
  1194.                     *task->fc->p++ = FORTH_RETSTACK;
  1195.                     (void) push (&task->retstack, (int32) task->fc->p);
  1196.                     task->fc->p += sizeof (int32);
  1197.                     (void) push (&task->retstack, 0);
  1198.                 }
  1199.                 if (stricmp (wp->name, "ELSE") == 0 ||
  1200.                     stricmp (wp->name, "THEN") == 0) {
  1201.                     if (pop (&task->retstack, &val) == -1) {
  1202.                         tputs (synerr);
  1203.                         free ((char *) task->fc);
  1204.                         return -1;
  1205.                     }
  1206.                     if (stricmp (wp->name, "THEN") == 0) {
  1207.                         if (val == 0) {    /* there was no ELSE word */
  1208.                             if (pop (&task->retstack, &val) == -1) {
  1209.                                 tputs (synerr);
  1210.                                 free ((char *) task->fc);
  1211.                                 return -1;
  1212.                             }
  1213.                             val = -1;    /* signal no ELSE */
  1214.                             if (pop (&task->retstack, &val) == -1) {
  1215.                                 tputs (synerr);
  1216.                                 free ((char *) task->fc);
  1217.                                 return -1;
  1218.                             }
  1219.                         }
  1220.                     } else if (pop (&task->retstack, &val) == -1) {
  1221.                         tputs (synerr);
  1222.                         free ((char *) task->fc);
  1223.                         return -1;
  1224.                     }
  1225.                     val = (int32) (task->fc->p - task->fc->buf)
  1226.                         + 1 + (int32) sizeof (wp);
  1227.                 }
  1228.                 *task->fc->p++ = FORTH_FIXEDENTRY;
  1229.                 *(struct wordlist **) task->fc->p = wp;
  1230.                 task->fc->p += sizeof (wp);
  1231.                 if (wp->args < 0) {    /* this word takes arguments */
  1232.                     task->fc->arg = -wp->args;
  1233.                     return 0;
  1234.                 }
  1235.                 /* a string is delivered as one single word */
  1236.                 if (wp->args > 0) {
  1237.                     task->delimiter = wp->args;
  1238.                     task->fc->arg = 1;
  1239.                     return 0;
  1240.                 }
  1241.                 /* some special cases */
  1242.                 if (stricmp (wp->name, "DECIMAL") == 0)
  1243.                     task->fc->base = 10;
  1244.                 else if (stricmp (wp->name, "HEX") == 0)
  1245.                     task->fc->base = 16;
  1246.                 else if (stricmp (wp->name, "OCTAL") == 0)
  1247.                     task->fc->base = 8;
  1248.                 return 0;
  1249.             }
  1250.             wp++;
  1251.         }
  1252.         if (isnumber (task->word, task->fc->base)) {
  1253.             *task->fc->p++ = FORTH_INT32;
  1254.             *(int32 *) task->fc->p = atoi32 (task->word, task->fc->base);
  1255.             task->fc->p += sizeof (int32);
  1256.             return 0;
  1257.         }
  1258.         tprintf ("%s?\n", task->word);    /* no match */
  1259.         task->args = 1;
  1260.         free ((char *) task->fc);
  1261.         return -1;
  1262.     } else {        /* this word is an argument */
  1263.         cp = mallocw (strlen (task->word) + 1);
  1264.         strcpy (cp, task->word);
  1265.         *task->fc->p++ = FORTH_ARGUMENT;
  1266.         *(char **) task->fc->p = cp;
  1267.         task->fc->p += sizeof (cp);
  1268.         task->fc->arg--;
  1269.     }
  1270.     return 0;
  1271. }
  1272.  
  1273.  
  1274.  
  1275. static int
  1276. doprint (struct forth *task)
  1277. {
  1278.     tputs (task->word);
  1279.     return 0;
  1280. }
  1281.  
  1282.  
  1283.  
  1284. static int
  1285. docr (struct forth *task OPTIONAL)
  1286. {
  1287.     tputc ('\n');
  1288.     return 0;
  1289. }
  1290.  
  1291.  
  1292.  
  1293. static int
  1294. doemit (struct forth *task)
  1295. {
  1296. int32 val;
  1297.  
  1298.     if (pop (&task->stack, &val) == -1)
  1299.         return errnostack (task);
  1300.     tputc ((unsigned char) val);
  1301.     return 0;
  1302. }
  1303.  
  1304.  
  1305.  
  1306. static int
  1307. dospaces (struct forth *task)
  1308. {
  1309. int32 val;
  1310.  
  1311.     if (strlen (task->word) == 5)
  1312.         val = 1;
  1313.     else if (pop (&task->stack, &val) == -1)
  1314.         return errnostack (task);
  1315.     while (val--)
  1316.         tputc (' ');
  1317.     return 0;
  1318. }
  1319.  
  1320.  
  1321.  
  1322. static int
  1323. dokey (struct forth *task)
  1324. {
  1325. int32 val;
  1326.  
  1327.     if ((val = recvchar (task->s)) == EOF)
  1328.         return -1;
  1329.     return push (&task->stack, val);
  1330. }
  1331.  
  1332.  
  1333.  
  1334. static int
  1335. doifelse (struct forth *task)
  1336. {
  1337. int32 offset, val;
  1338.  
  1339.     if (pop (&task->retstack, &offset) == -1)
  1340.         return errnostack (task);
  1341.     if (task->word[0] == 'i' || task->word[0] == 'I') {    /* IF word */
  1342.         if (pop (&task->stack, &val) == -1)
  1343.             return errnostack (task);
  1344.         if (val == 0) {
  1345.             task->goaddr = offset;    /* jump past the ELSE word */
  1346.             if (pop (&task->retstack, &offset) == -1)    /* the THEN offset */
  1347.                 return errnostack (task);
  1348.             if (task->goaddr == -1)    /* there is no ELSE word */
  1349.                 task->goaddr = offset;    /* go directly past THEN */
  1350.         }
  1351.     } else            /* ELSE word */
  1352.         task->goaddr = offset;    /* jump past the THEN word */
  1353.     return 0;
  1354. }
  1355.  
  1356.  
  1357.  
  1358. static int
  1359. doforthnothing (struct forth *task OPTIONAL)
  1360. {
  1361.     return 0;
  1362. }
  1363.  
  1364.  
  1365.  
  1366. static int
  1367. doforthuntil (struct forth *task)
  1368. {
  1369. int32 val, offset;
  1370.  
  1371.     if (pop (&task->retstack, &offset) == -1)
  1372.         return errnostack (task);
  1373.     if (task->word[0] == 'a' || task->word[0] == 'A' ||
  1374.         task->word[0] == 'r' || task->word[0] == 'R')    /* AGAIN, REPEAT */
  1375.         task->goaddr = offset;
  1376.     else {            /* UNTIL, END, WHILE */
  1377.         if (pop (&task->stack, &val) == -1)
  1378.             return errnostack (task);
  1379.         if (val == 0)
  1380.             task->goaddr = offset;
  1381.     }
  1382.     return 0;
  1383. }
  1384.  
  1385.  
  1386.  
  1387. static int
  1388. dodo (struct forth *task)
  1389. {
  1390. int32 val1, val2;
  1391.  
  1392.     if (pop (&task->stack, &val1) == -1)
  1393.         return errnostack (task);
  1394.     if (pop (&task->stack, &val2) == -1)
  1395.         return errnostack (task);
  1396.     (void) push (&task->retstack, val2);
  1397.     return push (&task->retstack, val1);
  1398. }
  1399.  
  1400.  
  1401.  
  1402. static int
  1403. doloop (struct forth *task)
  1404. {
  1405. int32 i, j, fin, step = 1, offset;
  1406.  
  1407.     if (task->word[0] == '+')
  1408.         if (pop (&task->stack, &step) == -1)
  1409.             return errnostack (task);
  1410.     if (pop (&task->retstack, &i) == -1)
  1411.         return errnostack (task);
  1412.     if (task->word[0] == 'i' || task->word[0] == 'I') {    /* I */
  1413.         (void) push (&task->retstack, i);
  1414.         return push (&task->stack, i);
  1415.     }
  1416.     if (pop (&task->retstack, &fin) == -1)
  1417.         return errnostack (task);
  1418.     if (task->word[1] == 'e' || task->word[1] == 'E') {    /* LEAVE */
  1419.         fin = i;
  1420.         (void) push (&task->retstack, fin);
  1421.         return push (&task->retstack, i);
  1422.     }
  1423.     if (pop (&task->retstack, &offset) == -1)
  1424.         return errnostack (task);
  1425.     if (task->word[0] == 'j' || task->word[0] == 'J') {    /* J */
  1426.         if (pop (&task->retstack, &j) == -1)
  1427.             return errnostack (task);
  1428.         (void) push (&task->retstack, j);
  1429.         (void) push (&task->retstack, offset);
  1430.         (void) push (&task->retstack, fin);
  1431.         (void) push (&task->retstack, i);
  1432.         return push (&task->stack, j);
  1433.     }
  1434.     i += step;        /* LOOP, +LOOP */
  1435.     if (i >= fin)
  1436.         return 0;
  1437.     task->goaddr = offset;
  1438.     (void) push (&task->retstack, offset);
  1439.     (void) push (&task->retstack, fin);
  1440.     return push (&task->retstack, i);
  1441. }
  1442.  
  1443.  
  1444.  
  1445. /* load FORTH words from a file */
  1446. static int
  1447. doload (struct forth *task)
  1448. {
  1449.     if ((task->fp = fopen (task->word, READ_TEXT)) == NULLFILE) {
  1450.         tprintf ("CANNOT OPEN %s\n", task->word);
  1451.         return -1;
  1452.     }
  1453.     return 0;
  1454. }
  1455.  
  1456.  
  1457.  
  1458. static int
  1459. doquit (struct forth *task)
  1460. {
  1461. struct mbuf *bp, *bprev;
  1462. char buf[9];
  1463. struct vocentry *ve;
  1464.  
  1465.     bp = task->vocabulary;
  1466.     bprev = NULLBUF;
  1467.     while (bp != NULLBUF) {
  1468.         ve = (struct vocentry *) bp->data;
  1469.         if ((ve->type == FORTH_VARIABLE || ve->type == FORTH_CONSTANT) &&
  1470.             *(bp->data + sizeof (struct vocentry)) != FORTH_NORMAL)
  1471.                      break;
  1472.  
  1473.         bprev = bp;
  1474.         bp = bp->anext;
  1475.     }
  1476.     if (bprev != NULLBUF) {
  1477.         ve = (struct vocentry *) bprev->data;
  1478.         task->final = 0;
  1479.         task->word = buf;
  1480.         strcpy (buf, ve->name);
  1481.         (void) doforget (task);
  1482.     }
  1483.     free_q (&task->vocabulary);
  1484.     if (task->fp != NULLFILE)
  1485.         (void) fclose (task->fp);
  1486.     free_q (&task->pad);
  1487.     return -1;
  1488. }
  1489.  
  1490.  
  1491.  
  1492. /* "n BUFFER addr" where addr is the address of buffer #n. If the buffer
  1493.  * is non-existent, but buffer no #n-1 exists, a new buffer is allocated,
  1494.  * otherwise an error message is printed. The PAD area is buffer #1.
  1495.  */
  1496. static int
  1497. dobuffer (struct forth *task)
  1498. {
  1499. struct mbuf *bp;
  1500. int32 val, cnt = 1;
  1501.  
  1502.     if (task->word[0] == 'P' || task->word[0] == 'p')    /* PAD word */
  1503.         val = 1;
  1504.     else if (pop (&task->stack, &val) == -1)
  1505.         return errnostack (task);
  1506.     bp = task->pad;
  1507.     while (bp != NULLBUF) {
  1508.         if (cnt++ == val)
  1509.             return push (&task->stack, (int32) (bp->data + 1));
  1510.         bp = bp->anext;
  1511.     }
  1512.     if (cnt == val) {
  1513.         while ((bp = alloc_mbuf (256)) == NULLBUF)
  1514.             kwait (NULL);
  1515.         if (bp == NULLBUF)
  1516.             return -1;
  1517.         *bp->data = FORTH_NORMAL;
  1518.         enqueue (&task->pad, bp);
  1519.         return push (&task->stack, (int32) (bp->data + 1));
  1520.     }
  1521.     tprintf ("NO SUCH BUFFER\n");
  1522.     return -1;
  1523. }
  1524.  
  1525. static int
  1526. doexpect (struct forth *task)
  1527. {
  1528. int32 val, addr;
  1529. int cnt;
  1530. char *p;
  1531.  
  1532.     if (pop (&task->stack, &val) == -1)
  1533.         return errnostack (task);
  1534.     if (pop (&task->stack, &addr) == -1)
  1535.         return errnostack (task);
  1536.     if ((p = varcheck (task, addr)) == NULLCHAR)
  1537.         return -1;
  1538.     if (*p & FORTH_READONLY) {
  1539.         tprintf ("WRITE PROTECTED ADDRESS\n");
  1540.         return -1;
  1541.     }
  1542.     if (varcheck (task, addr + val - 1) == NULLCHAR)
  1543.         return -1;
  1544.     if (*p & FORTH_INDIRECT)
  1545.         p = (char *) (*(int32 **) (p + 1)) + addr - (int) (p + 1);
  1546.     else
  1547.         p = (char *) addr;
  1548.     if (task->word[0] == 'E' || task->word[0] == 'e') {    /* EXPECT */
  1549.         (void) recvline (task->s, (unsigned char *) p, (int16) val);
  1550. #if 0
  1551.         rip (addr);
  1552. #else
  1553.         rip (p);
  1554. #endif
  1555.     } else
  1556.         for (cnt = 0; cnt < val; ++cnt)    /* TYPE */
  1557.             tputc (uchar(p[cnt]));
  1558.     return 0;
  1559. }
  1560.  
  1561. #endif /* FORTH */
  1562.